home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / defoma / scripts / x-ttcidfont-conf.defoma < prev   
Text File  |  2008-06-17  |  24KB  |  1,070 lines
  1. @ACCEPT_CATEGORIES = qw(truetype cid cmap);
  2.  
  3. package x_ttcidfont_conf;
  4. use strict;
  5. use POSIX;
  6.  
  7. use vars qw($DEFOMA_TEST_DIR $ROOTDIR);
  8.  
  9. use Debian::Defoma::Common;
  10. use Debian::Defoma::Font;
  11. use Debian::Defoma::Id;
  12. import Debian::Defoma::Font;
  13. import Debian::Defoma::Id;
  14. import Debian::Defoma::Common;
  15.  
  16. my ($Id, $IdCmap, $IdSub);
  17.  
  18. my $configfile = "$DEFOMA_TEST_DIR/etc/defoma/config/x-ttcidfont-conf.conf";
  19. my $PkgDir = "$ROOTDIR/x-ttcidfont-conf.d";
  20. my $FontRootDir = "$PkgDir/dirs";
  21. my $Method;
  22. my @AliasSize = qw(8 10 12 14 16 18 20 22 24 26 28 30 32);
  23. my %SpacingC;
  24. my $Spacing;
  25. my $VL;
  26.  
  27. sub get_xlfd_element {
  28.     my $h = shift;
  29.     my $ret = {};
  30.  
  31.     $ret->{Foundry} = 'unknown';
  32.     $ret->{Foundry} = $h->{'Foundry'} if (exists($h->{'Foundry'}));
  33.     $ret->{Foundry} = $h->{'X-Foundry'} if (exists($h->{'X-Foundry'}));
  34.  
  35.     $ret->{Family} = 'unknown';
  36.     $ret->{Family} = $h->{'FontName'} if (exists($h->{'FontName'}));
  37.     $ret->{Family} = $h->{'Family'} if (exists($h->{'Family'}));
  38.     $ret->{Family} = $h->{'X-Family'} if (exists($h->{'X-Family'}));
  39.  
  40.  
  41.     $ret->{Weight} = 'medium';
  42.     $ret->{Weight} = $h->{'Weight'} if (exists($h->{'Weight'}));
  43.     $ret->{Weight} = $h->{'X-Weight'} if (exists($h->{'X-Weight'}));
  44.  
  45.     $ret->{Slant} = 'r';
  46.     $ret->{Slant} = 'o' if
  47.     (exists($h->{'Shape'}) && $h->{'Shape'} =~ /Oblique/);
  48.     $ret->{Slant} = 'i' if
  49.     (exists($h->{'Shape'}) && $h->{'Shape'} =~ /Italic/);
  50.     $ret->{Slant} = $h->{'X-Slant'} if (exists($h->{'X-Slant'}));
  51.  
  52.     $ret->{SetWidth} = 'normal';
  53.     $ret->{SetWidth} = 'condensed' if (exists($h->{'Shape'}) &&
  54.                        $h->{'Shape'} =~ /Condensed/);
  55.     $ret->{SetWidth} = 'expanded' if (exists($h->{'Shape'}) &&
  56.                       $h->{'Shape'} =~ /Expanded/);
  57.     $ret->{SetWidth} = $h->{'X-SetWidth'} if
  58.     (exists($h->{'X-SetWidth'}));
  59.  
  60.     $ret->{Style} = '';
  61.     $ret->{Style} = $h->{'X-Style'} if (exists($h->{'X-Style'}));
  62.  
  63.     $ret->{Pixel} = 0;
  64.     $ret->{Pixel} = $h->{'X-PixelSize'} if (exists($h->{'X-PixelSize'}));
  65.  
  66.     $ret->{Point} = 0;
  67.     $ret->{Point} = $h->{'X-PointSize'} if (exists($h->{'X-PointSize'}));
  68.  
  69.     $ret->{ResX} = 0;
  70.     $ret->{ResX} = $h->{'X-Resolution'} if
  71.     (exists($h->{'X-Resolution'}));
  72.  
  73.     $ret->{ResY} = 0;
  74.     $ret->{ResY} = $h->{'X-Resolution'} if
  75.     (exists($h->{'X-Resolution'}));
  76.  
  77.     $ret->{AvgWidth} = 0;
  78.     $ret->{AvgWidth} = $h->{'X-AverageWidth'} if
  79.     (exists($h->{'X-AverageWidth'}));
  80.  
  81.     $ret->{Encoding} = 'iso8859-1';
  82.     $ret->{Encoding} = $h->{'X-RegistryEncoding'} if
  83.     (exists($h->{'X-RegistryEncoding'}));
  84.  
  85.     $ret->{Spacing} = 'p';
  86.     $ret->{Spacing} = $Spacing if (defined($Spacing));
  87.     $ret->{Spacing} = $h->{'X-Spacing'} if (exists($h->{'X-Spacing'}));
  88.  
  89.     foreach my $k (keys(%{$ret})) {
  90.     $ret->{$k} =~ s/ .*//;
  91.     $ret->{$k} =~ tr/A-Z/a-z/;
  92.     $ret->{$k} =~ s/-/_/g if ($k ne 'Encoding');
  93.     }
  94.  
  95.     return $ret;
  96. }
  97.  
  98. sub generate_xlfd {
  99.     my $xe = shift;
  100.     my $h = shift;
  101.     my $xlfd;
  102.     my (@xlfds, @xlfdsb, @xlfds_, @xlfdsb_);
  103.     my ($i, $j);
  104.     my (@ret, @list);
  105.     
  106.  
  107.     $xlfdsb[0] = $xe->{Pixel};
  108.     $xlfdsb[1] = $xe->{Point};
  109.     $xlfdsb[2] = $xe->{ResX};
  110.     $xlfdsb[3] = $xe->{ResY};
  111.     $xlfdsb[4] = $xe->{Spacing};
  112.     $xlfdsb[5] = $xe->{AvgWidth};
  113.     $xlfdsb[6] = $xe->{Encoding};
  114.  
  115.     @xlfdsb_ = @xlfdsb;
  116.  
  117.     $xlfds[0] = $xe->{Foundry};
  118.     $xlfds[1] = $xe->{Family};
  119.     $xlfds[2] = $xe->{Weight};
  120.     $xlfds[3] = $xe->{Slant};
  121.     $xlfds[4] = $xe->{SetWidth};
  122.     $xlfds[5] = $xe->{Style};
  123.  
  124.     @xlfds_ = @xlfds;
  125.  
  126.     $xlfd = join('-', '', @xlfds, @xlfdsb);
  127.  
  128.     push(@ret, $xlfd);
  129.  
  130.     if (exists($h->{'X-Alias'})) {
  131.     @list = split(' ', $h->{'X-Alias'});
  132.     
  133.     foreach $i (@list) {
  134.         $i =~ tr/A-Z/a-z/;
  135.         $xlfd = join('-', $i, @xlfdsb);
  136.         push(@ret, $xlfd);
  137.     }
  138.     }
  139.  
  140.     if (exists($h->{'X-SimpleAlias'})) {
  141.     @list = split(' ', $h->{'X-SimpleAlias'});
  142.  
  143.     foreach $i (@list) {
  144.         $i =~ tr/A-Z/a-z/;
  145.         push(@ret, $i);
  146.     }
  147.     }
  148.  
  149.     if (exists($h->{'X-ElementAlias'})) {
  150.     @list = split(' ', $h->{'X-ElementAlias'});
  151.  
  152.     foreach $i (@list) {
  153.         $i =~ tr/A-Z/a-z/;
  154.         my @l = split(/:/, $i);
  155.         my @xs = (@xlfds, @xlfdsb);
  156.         my %c2e = ('foundry' => 0, 'family' => 1, 'weight' => 2,
  157.                'slant' => 3, 'setwidth' => 4, 'style' => 5,
  158.                'pixel' => 6, 'point' => 7, 'resx' => 8, 'resy' => 9,
  159.                'spacing' => 10, 'avgwidth' => 11, 'encoding' => 12);
  160.         
  161.         foreach my $p (@l) {
  162.         $p =~ /^([^=]+)=(.+)$/;
  163.  
  164.         $xs[$c2e{$1}] = $2;
  165.         }
  166.  
  167.         $xlfd = join('-', '', @xs);
  168.         push(@ret, $xlfd);
  169.     }
  170.     }
  171.  
  172.     return @ret;
  173. }
  174.  
  175. sub generate_alias {
  176.     my $o = shift;
  177.     my $i = shift;
  178.     my $aliasptr = shift;
  179.  
  180.     my $id = $o->{0}->[$i];
  181.     my $oid = $o->{5}->[$i];
  182.     my @l;
  183.     my ($p, $size, $psize, $sid, $soid, $flag, $j);
  184.  
  185.     $id =~ s/_/ /g;
  186.     $oid =~ s/_/ /g;
  187.  
  188.     my @xe = split(/-/, $id);
  189.     
  190.     if ($xe[7] == 0 && $xe[8] == 0) {
  191.     foreach $size (@AliasSize) {
  192.         $psize = $size * 10;
  193.         $xe[7] = $size;
  194.         $xe[8] = $psize;
  195.         $xe[12] = $psize;
  196.         $sid = join('-', @xe);
  197.         
  198.         $soid = $oid;
  199.         $soid =~ s/-0-0-0-0-/-$size-$psize-0-0-/;
  200.         
  201.         push(@{$aliasptr}, "\"$sid\" \"$soid\"");
  202.     }
  203.     } elsif ($xe[0]) {
  204.     foreach $size (@AliasSize) {
  205.         $psize = $size * 10;
  206.         $sid = $id.'-'.$size;
  207.         
  208.         $soid = $oid;
  209.         $soid =~ s/-0-0-0-0-/-$size-$psize-0-0-/;
  210.         
  211.         push(@{$aliasptr}, "\"$sid\" \"$soid\"");
  212.     }
  213.     } else {
  214.     $soid = $oid;
  215.     $soid =~ s/-0-0-0-0-/-$xe[7]-$xe[8]-$xe[9]-$xe[10]-/;
  216.     
  217.     push(@{$aliasptr}, "\"$id\" \"$soid\"");
  218.     
  219.     return 0;
  220.     }
  221.     
  222.     push(@{$aliasptr}, "\"$id\" \"$oid\"");
  223. }
  224.  
  225. sub write_resource_files {
  226.     my $category = shift;
  227.     my $scaleptr = shift;
  228.     my $aliasptr = shift;
  229.  
  230.     my $fscale = "$PkgDir/dirs/$category/fonts.scale";
  231.     my $falias = "$PkgDir/dirs/$category/fonts.alias";
  232.  
  233.     open(F, '>' . $fscale) || return 0;
  234.     my $lnum = @{$scaleptr};
  235.  
  236.     print F $lnum, "\n";
  237.  
  238.     foreach my $i (@{$scaleptr}) {
  239.     print F $i, "\n";
  240.     }
  241.  
  242.     close F;
  243.  
  244.     open(F, '>' . $falias) || return 0;
  245.  
  246.     foreach my $i (@{$aliasptr}) {
  247.     print F $i, "\n";
  248.     }
  249.  
  250.     close F;
  251.  
  252.     system('/usr/bin/X11/mkfontdir',
  253.     '-e', '/usr/share/fonts/X11/encodings',
  254.     '-e', '/usr/share/fonts/X11/encodings/large',
  255.     "$PkgDir/dirs/$category");
  256.  
  257.     return 0;
  258. }
  259.  
  260. sub register_all {
  261.     my $o = shift;
  262.     my $font = shift;
  263.     my $pri = shift;
  264.     my $xe = shift;
  265.     my $h = shift;
  266.     my $ctg = shift;
  267.     
  268.     my @hints = parse_hints_build($h);
  269.     my @xlfds = generate_xlfd($xe, $h);
  270.     my %add = ();
  271.  
  272.     $add{category} = $ctg if ($ctg);
  273.  
  274.     my $xlfd0 = shift(@xlfds);
  275.  
  276.     defoma_id_register($o, type => 'real', font => $font, id => $xlfd0,
  277.                priority => $pri, hints => join(' ', @_, @hints),
  278.                %add);
  279.  
  280.     while (@xlfds) {
  281.     my $xlfd = shift(@xlfds);
  282.  
  283.     defoma_id_register($o, type => 'alias', font => $font, id => $xlfd,
  284.                priority => $pri, origin => $xlfd0, %add);
  285.     }
  286. }
  287.  
  288. ###
  289.  
  290. sub parse_config_file {
  291.     $Method = 'xtt';
  292.  
  293.     if (open(F, $configfile)) {
  294.     while (<F>) {
  295.         next if ($_ =~ /^\#/);
  296.         chomp($_);
  297.  
  298.         if ($_ =~ /^X_TRUETYPE_METHOD=(xtt|freetype)\s*$/) {
  299.         $Method = $1;
  300.         }
  301.         if ($_ =~ /^XTT_VL=([ynYN])\s*$/) {
  302.         $VL = ($1 =~ /[yY]/) ? 1 : 0;
  303.         }
  304.     }
  305.     close F;
  306.     }
  307. }
  308.  
  309. sub parse_config_file2 {
  310.     %SpacingC = ();
  311.  
  312.     if (open(F, $configfile . "2")) {
  313.     while (<F>) {
  314.         next if ($_ =~ /^\#/);
  315.         chomp($_);
  316.         my @a = split(' ', $_);
  317.         my $l = shift(@a);
  318.  
  319.         if (defined($l)) {
  320.         $SpacingC{$l} = undef;
  321.         }
  322.     }
  323.     close F;
  324.     }
  325. }
  326.  
  327. sub init {
  328.     unless ($Method) {
  329.     parse_config_file();
  330.     parse_config_file2();
  331.     }
  332.     unless ($Id) {
  333.     $Id = defoma_id_open_cache();
  334.     $IdCmap = defoma_id_open_cache('cmap');
  335.     $IdCmap->{callback} = 0;
  336.     $IdSub = defoma_id_open_cache('sub');
  337.     $IdSub->{callback} = 0;
  338.     }
  339.     
  340.     return 0;
  341. }
  342.  
  343. my $done = 0;
  344.  
  345. sub term {
  346.     unless ($done) {
  347.     $done = 1;
  348.     defoma_id_close_cache($Id);
  349.     defoma_id_close_cache($IdCmap);
  350.     defoma_id_close_cache($IdSub);
  351.     }
  352.  
  353.     return 0;
  354. }
  355.  
  356. sub make_link {
  357.     my $diro = shift;
  358.     my $font = shift;
  359.     my $fname = shift;
  360.  
  361.     my $fontfile;
  362.     
  363.     if ($fname) {
  364.     $fontfile = $fname;
  365.     } else {
  366.     return 1 unless($font =~ /^(.*)\/(.+)$/);
  367.     $fontfile = $2;
  368.     }
  369.     
  370.     my $dir = $FontRootDir.$diro;
  371.     
  372.     return 1 if (-e $dir . $fontfile);
  373.     symlink($font, $dir . $fontfile) || return 1;
  374.  
  375.     return 0;
  376. }
  377.  
  378. sub remove_link {
  379.     my $diro = shift;
  380.     my $font = shift;
  381.     my $fname = shift;
  382.  
  383.     my $fontfile = shift;
  384.     
  385.     if ($fname) {
  386.     $fontfile = $fname;
  387.     } else {
  388.     return 1 unless($font =~ /^(.*)\/(.+)$/);
  389.     $fontfile = $2;
  390.     }
  391.     
  392.     my $dir = $FontRootDir.$diro;
  393.  
  394.     return 1 unless(-l $dir . $fontfile);
  395.     unlink($dir . $fontfile);
  396.  
  397.     return 0;
  398. }
  399.  
  400. ### CATEGORY: TrueType
  401.  
  402. sub xtt_register {
  403.     my $font = shift;
  404.     my $facenum = shift;
  405.     my $face = shift;
  406.     my $ttcap = shift;
  407.     my $pri = shift;
  408.     my $h = shift;
  409.  
  410.     my $i_angle = 0.4;
  411.     my $o_angle = 0.2;
  412.     my $boldstring = 'bold';
  413.     my $hw_bw = '';
  414.     my $hw_sw = '';
  415.     my $nobold = 0;
  416.     my $nori = 0;
  417.     my $noi = 0;
  418.     my $noo = 0;
  419.     my $noro = 0;
  420.  
  421.     my %horig;
  422.     my $k;
  423.     foreach $k (keys(%{$h})) {
  424.     $horig{$k} = $h->{$k};
  425.     }
  426.  
  427.     if ($ttcap) {
  428.     my @l = split(' ', $ttcap);
  429.     foreach my $i (@l) {
  430.         if ($i =~ /^italic-angle=(.+)$/) {
  431.         $i_angle = $1;
  432.         } elsif ($i =~ /^oblique-angle=(.+)$/) {
  433.         $o_angle = $1;
  434.         } elsif ($i =~ /^halfwidth-bw=(.+)$/) {
  435.         $hw_bw = $1;
  436.         } elsif ($i =~ /^halfwidth-sw=(.+)$/) {
  437.         $hw_sw = $1;
  438.         } elsif ($i =~ /^bold-string=(.+)$/) {
  439.         $boldstring = $1;
  440.         $boldstring =~ tr/A-Z/a-z/;
  441.         } elsif ($i eq 'no-bold') {
  442.         $nobold = 1;
  443.         } elsif ($i eq 'no-ritalic') {
  444.         $nori = 1;
  445.         } elsif ($i eq 'no-italic') {
  446.         $noi = 1;
  447.         } elsif ($i eq 'no-roblique') {
  448.         $noro = 1;
  449.         } elsif ($i eq 'no-oblique') {
  450.         $noo = 1;
  451.         }
  452.     }
  453.     }
  454.  
  455.     my $ttcapbase = '';
  456.     $ttcapbase = 'fn='.$face.':' if ($facenum > 1);
  457.     my $ttcapbase_hw = '';
  458.  
  459.     if ($h->{'X-RegistryEncoding'} !~/^(jisx0208\.|jisx0212\.|jisx0213\.|gb2312\.|big5|ksc5601\.|gbk|gb18030)/) {
  460.     $ttcapbase_hw .= 'bw='.$hw_bw.':' if ($hw_bw);
  461.     $ttcapbase_hw .= 'sw='.$hw_sw.':' if ($hw_sw);
  462.     }
  463.  
  464.     my $xe = get_xlfd_element($h);
  465.     my $weight0 = $xe->{Weight};
  466.     my $slant0 = $xe->{Slant};
  467.     my $space0 = $xe->{Spacing};
  468.     
  469.     my $hweight0 = $h->{Weight};
  470.     my $hwidth0 = $h->{Width};
  471.     my $hshape0 = $h->{Shape} || '';
  472.     $hshape0 =~ s/(Upright|Italic|Oblique|)//g;
  473.     my $hslant0 = $1 || 'Upright';
  474.     
  475.     my @italiclist = ($slant0);
  476.     if ($slant0 eq 'r' &&
  477.     (($h->{Transform} && $h->{Transform} !~ /NotSlant/) ||
  478.      ! $h->{Transform})) {
  479.     push(@italiclist, 'i') unless ($noi);
  480.     push(@italiclist, 'ri') unless ($nori);
  481.     push(@italiclist, 'o') unless ($noo);
  482.     push(@italiclist, 'ro') unless ($noro);
  483.     }
  484.     
  485.     my @boldlist = ($weight0);
  486.     if ($weight0 ne $boldstring &&
  487.     (($h->{Transform} && $h->{Transform} !~ /NotBoldize/) ||
  488.      ! $h->{Transform})) {
  489.     push(@boldlist, $boldstring) unless ($nobold);
  490.     }
  491.  
  492.     my @spclist = ($space0);
  493.     if ($h->{'X-Spacing'}) {
  494.     @spclist = split(' ', $h->{'X-Spacing'});
  495.     } elsif ($Spacing) {
  496.     push(@spclist, ($Spacing eq 'c') ? 'm' : 'c');
  497.     }
  498.     
  499.     my $fontname0 = $h->{FontName};
  500.     my $fontname0_b = $h->{'FontName-Bold'};
  501.     my $fontname0_bi = $h->{'FontName-BoldItalic'};
  502.     my $fontname0_i = $h->{'FontName-Italic'};
  503.     
  504.     parse_hints_cut($h, 'X-Weight', 'X-Slant', 'X-Spacing');
  505.  
  506.     my $idobj = $Id;
  507.     
  508.     foreach my $spc (@spclist) {
  509.     $xe->{Spacing} = $spc;
  510.  
  511.     foreach my $slant (@italiclist) {
  512.         $h->{Shape} = $hshape0.' ';
  513.         $h->{Shape} .= ($slant eq $slant0) ? $hslant0 : 'Italic';
  514.         $xe->{Slant} = $slant;
  515.         
  516.         foreach my $weight (@boldlist) {
  517.         $h->{Weight} = $hweight0 if ($hweight0);
  518.         $h->{Weight} = 'Bold' if ($weight eq $boldstring);
  519.         $xe->{Weight} = $weight;
  520.  
  521.         my $ttcap = $ttcapbase;
  522.         $ttcap .= $ttcapbase_hw if ($spc eq 'c');
  523.         $ttcap .= 'vl=y:' if ($spc ne 'c' && $VL);
  524.         $ttcap .= 'ds=y:' if ($weight ne $weight0);
  525.         $ttcap .= 'ai='.$i_angle.':' if ($slant eq 'i');
  526.         $ttcap .= 'ai=-'.$i_angle.':' if ($slant eq 'ri');
  527.         $ttcap .= 'ai='.$o_angle.':' if ($slant eq 'o');
  528.         $ttcap .= 'ai=-'.$o_angle.':' if ($slant eq 'ro');
  529.         
  530.         $ttcap = '.' unless($ttcap);
  531.  
  532.         if ($weight eq $boldstring && $slant eq 'i') {
  533.             $h->{FontName} = $fontname0_bi || $fontname0;
  534.         } elsif ($weight eq $boldstring) {
  535.             $h->{FontName} = $fontname0_b || $fontname0;
  536.         } elsif ($slant eq 'i') {
  537.             $h->{FontName} = $fontname0_i || $fontname0;
  538.         } else {
  539.             $h->{FontName} = $fontname0;
  540.         }
  541.  
  542.         register_all($idobj, $font, $pri, $xe, $h, '', $ttcap);
  543.         }
  544.         $idobj = $IdSub if ($slant ne 'r');
  545.     }
  546.     $idobj = $IdSub;
  547.     }
  548.  
  549.     foreach $k (keys(%horig)) {
  550.     $h->{$k} = $horig{$k};
  551.     }
  552. }
  553.  
  554. sub freetype_register {
  555.     my $font = shift;
  556.     my $facenum = shift;
  557.     my $face = shift;
  558.     my $pri = shift;
  559.     my $h = shift;
  560.  
  561.     my $cap = '.';
  562.     $cap = ':'.$face.':' if ($facenum > 1);
  563.  
  564.     my $hwidth = $h->{Width};
  565.     my $xe = get_xlfd_element($h);
  566.  
  567.     register_all($Id, $font, $pri, $xe, $h, '', $cap);
  568.  
  569. #    
  570.     if ($h->{'X-Spacing'}) {
  571.     my @spclist = split(' ', $h->{'X-Spacing'});
  572.     
  573.     shift(@spclist);
  574.     foreach my $spc (@spclist) {
  575.         $xe->{Spacing} = $spc;
  576.         
  577.         register_all($IdSub, $font, $pri, $xe, $h, '', $cap);
  578.     }
  579.     } elsif ($Spacing) {
  580.     $xe->{Spacing} = $Spacing eq 'c' ? 'm' : 'c';
  581.     
  582.     register_all($IdSub, $font, $pri, $xe, $h, '', $cap);
  583.     }
  584. }
  585.  
  586. sub tt_register {
  587.     my $font = shift;
  588.  
  589.     make_link('/TrueType/', $font) && return 1;
  590.     
  591.     my $hh = parse_hints_start(@_);
  592.     
  593.     my $facenum = $hh->{FaceNum} || 1;
  594.     parse_hints_cut($hh, 'FaceNum');
  595.     my ($i, $j);
  596.     my $noerror = 0;
  597.  
  598.     for ($i = 0; $i < $facenum; $i++) {
  599.     my $h = parse_hints_subhints_inherit($hh, $i);
  600.     parse_hints_cut($h, 'Encoding');
  601.     parse_hints_cut($h, 'X-Alias', 'X-SimpleAlias') if ($Method eq 'xtt');
  602.     my $pri = $h->{Priority} || 0;
  603.     next unless ($h->{FontName});
  604.     
  605.     my %xencoding;
  606.  
  607.     if (exists($h->{Charset})) {
  608.         my @charset = split(' ', $h->{'Charset'});
  609.  
  610.         foreach $j (@charset) {
  611.         my $x = get_xencoding($j, '');
  612.         $xencoding{$x} = $j if ($x);
  613.         }
  614.     }
  615.  
  616.     my @xenc;
  617.     if ($h->{'X-RegistryEncoding'}) {
  618.         @xenc = split(' ', $h->{'X-RegistryEncoding'});
  619.         foreach $j (@xenc) {
  620.         my $c = get_charset($j);
  621.         $xencoding{$j} = $c;
  622.         }
  623.     }
  624.  
  625.     $noerror = 1;
  626.  
  627.     @xenc = keys(%xencoding);
  628.  
  629.     undef $Spacing;
  630.     if ($h->{Width} && $h->{Width} eq 'Fixed') {
  631.         if (grep(exists($SpacingC{$_}), @xenc)) {
  632.         $Spacing = 'c';
  633.         } else {
  634.         $Spacing = 'm';
  635.         }
  636.     }
  637.     
  638.     foreach my $xe (@xenc) {
  639.         my $cset = $xencoding{$xe};
  640.  
  641.         $h->{'X-RegistryEncoding'} = $xe;
  642.         parse_hints_cut($h, 'Charset');
  643.         $h->{'Charset'} = $cset if ($cset);
  644.  
  645.         if ($Method eq 'xtt') {
  646.         xtt_register($font, $facenum, $i, $h->{TTCap}, $pri, $h);
  647.         } else {
  648.         freetype_register($font, $facenum, $i, $pri, $h);
  649.         }
  650.     }
  651.     }
  652.  
  653.     unless ($noerror) {
  654.     remove_link('/TrueType/', $font);
  655.     return 2;
  656.     }
  657.  
  658.     return 0;
  659. }
  660.  
  661. sub tt_unregister {
  662.     my $font = shift;
  663.  
  664.     remove_link('/TrueType/', $font);
  665.  
  666.     defoma_id_unregister($Id, type => 'alias', font => $font);
  667.     defoma_id_unregister($Id, type => 'real', font => $font);
  668.     defoma_id_unregister($IdSub, type => 'alias', font => $font);
  669.     defoma_id_unregister($IdSub, type => 'real', font => $font);
  670.  
  671.     return 0;
  672. }
  673.  
  674. sub tt_install {
  675.     my $font = shift;
  676.     my $id = shift;
  677.     shift;
  678.     shift;
  679.     shift;
  680.  
  681.     defoma_font_register('xfont', $id, @_);
  682. }
  683.  
  684. sub tt_remove {
  685.     my $font = shift;
  686.     my $id = shift;
  687.  
  688.     defoma_font_unregister('xfont', $id);
  689. }
  690.  
  691. sub tt_term {
  692.     my @scale = ();
  693.     my @alias = ();
  694.     my $file;
  695.     my $id;
  696.     my $oid;
  697.  
  698.     my @l = defoma_id_grep_cache($Id, 'installed', f4 => 'truetype');
  699.     foreach my $i (@l) {
  700.     $id = $Id->{0}->[$i];
  701.     $id =~ s/_/ /g;
  702.  
  703.     if ($Id->{2}->[$i] eq 'SrI') {
  704.         $file = $Id->{1}->[$i];
  705.         $file =~ s/^(.*)\///;
  706.  
  707.         my $cap = $Id->{7}->[$i];
  708.         $cap =~ s/ .*$//;
  709.         $cap = '' if ($cap eq '.');
  710.  
  711.         push(@scale, $cap.$file.' '.$id);
  712.     } else {
  713.         generate_alias($Id, $i, \@alias);
  714.     }
  715.     }
  716.  
  717.     @l = defoma_id_grep_cache($IdSub, 'installed', f4 => 'truetype');
  718.     foreach my $i (@l) {
  719.     $id = $IdSub->{0}->[$i];
  720.     $id =~ s/_/ /g;
  721.  
  722.     if ($IdSub->{2}->[$i] eq 'SrI') {
  723.         $file = $IdSub->{1}->[$i];
  724.         $file =~ s/^(.*)\///;
  725.  
  726.         my $cap = $IdSub->{7}->[$i];
  727.         $cap =~ s/ .*$//;
  728.         $cap = '' if ($cap eq '.');
  729.  
  730.         push(@scale, $cap.$file.' '.$id);
  731.     } else {
  732.         generate_alias($IdSub, $i, \@alias);
  733.     }
  734.     }
  735.  
  736.     write_resource_files('TrueType', \@scale, \@alias);
  737.  
  738.     term();
  739.  
  740.     return 0;
  741. }
  742.  
  743. sub truetype {
  744.     my $com = shift;
  745.  
  746.     if ($com eq 'register') {
  747.     return tt_register(@_);
  748.     } elsif ($com eq 'unregister') {
  749.     return tt_unregister(@_);
  750.     } elsif ($com eq 'do-install-real') {
  751.     return tt_install(@_);
  752.     } elsif ($com eq 'do-remove-real') {
  753.     return tt_remove(@_);
  754.     } elsif ($com eq 'init') {
  755.     return init();
  756.     } elsif ($com eq 'term') {
  757.     return tt_term();
  758.     }
  759.  
  760.     return 0;
  761. }
  762.  
  763. ### CATEGORY: cid
  764.  
  765. my $cid_term_done = 0;
  766.  
  767. sub cid_term {
  768.     return 0 if ($cid_term_done);
  769.     
  770.     my @l = defoma_id_grep_cache($Id, 'installed', f4 => 'cid');
  771.     my @scale = ();
  772.     my @alias = ();
  773.     my $id;
  774.     my $oid;
  775.  
  776.     foreach my $i (@l) {
  777.     $id = $Id->{0}->[$i];
  778.     next if ($id =~ /^CID:/);
  779.     $id =~ s/_/ /g;
  780.     
  781.     if ($Id->{2}->[$i] eq 'SrI') {
  782.         my $cidfont = $Id->{1}->[$i];
  783.  
  784.         push(@scale, $cidfont . ' ' . $id);
  785.     } else {
  786.         generate_alias($Id, $i, \@alias);
  787.     }
  788.     }
  789.  
  790.     write_resource_files('CID', \@scale, \@alias);
  791.     if ( -e '/usr/bin/mkcfm')
  792.     {
  793.         system('/usr/bin/mkcfm', "$PkgDir/dirs/CID");
  794.     }
  795.  
  796.     term();
  797.  
  798.     return 0;
  799. }
  800.  
  801. sub cid_check_dir {
  802.     my ($reg, $ord) = @_;
  803.  
  804.     my $dir = $FontRootDir.'/CID/'.$reg.'-'.$ord.'/';
  805.  
  806.     unless (-d $dir) {
  807.     mkdir($dir, 0755) || return 1;
  808.  
  809.     mkdir($dir.'CIDFont', 0755) || return 1;
  810.     mkdir($dir.'AFM', 0755) || return 1;
  811.     mkdir($dir.'CFM', 0755) || return 1;
  812.     mkdir($dir.'CMap', 0755) || return 1;
  813.     }
  814.  
  815.     return 0;
  816. }
  817.  
  818. sub cid_register_all {
  819.     my $font = shift;
  820.     my $cmap = shift;
  821.     my $reg = shift;
  822.     my $ord = shift;
  823.     my $cset = shift;
  824.     my $enc = shift;
  825.     my $xenc = shift;
  826.     my $h = shift;
  827.  
  828.     $h->{'X-RegistryEncoding'} = $xenc;
  829.     $h->{'Charset'} = $cset if ($cset ne '.');
  830.     $h->{'Encoding'} = $enc if ($enc ne '.');
  831.  
  832.     my $pri = $h->{Priority} || 0;
  833.     my $fontname = $h->{FontName};
  834.     
  835.     my $xe = get_xlfd_element($h);
  836.  
  837.     $font =~ /(.*)\/(.+)/;
  838.     my $cidfont = $reg.'-'.$ord.'/'.$2.'--'.$cmap.'.cid';
  839.  
  840.     register_all($Id, $cidfont, $pri, $xe, $h, 'cid');
  841.  
  842.     return 0;
  843. }
  844.  
  845. sub cid_register {
  846.     my $font = shift;
  847.     return 1 unless ($font =~ /(.*)\/(.+)/);
  848.     
  849.     my $h = parse_hints_start(@_);
  850.     
  851.     my $reg = $h->{CIDRegistry};
  852.     my $ord = $h->{CIDOrdering};
  853.     my $fontname = $h->{FontName};
  854.     return 1 unless ($reg && $ord && $fontname);
  855.  
  856.     cid_check_dir($reg, $ord) && return 2;
  857.  
  858.     my $dir = '/CID/'.$reg.'-'.$ord.'/';
  859.  
  860.     make_link($dir.'CIDFont/', $font, $fontname) && return 3;
  861.  
  862.     if (exists($h->{AFM})) {
  863.     my $afm = $h->{AFM};
  864.  
  865.     if (make_link($dir.'AFM/', $afm, $fontname.'.afm')) {
  866.         remove_link($dir.'CIDFont/', $font, $fontname);
  867.         return 4;
  868.     }
  869.     }
  870.     
  871.     my $pri = $h->{Priority} || 0;
  872.  
  873.     parse_hints_cut($h, 'CIDRegistry', 'CIDSupplement', 'CIDOrdering',
  874.             'Charset', 'Encoding', 'AFM');
  875.     my @hints = parse_hints_build($h);
  876.  
  877.     defoma_id_register($IdCmap, type => 'real', font => $font,
  878.                id => $reg.'-'.$ord.'/'.$fontname,
  879.                priority => $pri,
  880.                hints => join(' ', $reg, $ord, @hints));
  881.  
  882.     my @l = defoma_id_grep_cache($IdCmap, 'real', r0 => $reg.'-'.$ord.'/.*',
  883.                  f4 => 'cmap');
  884.  
  885.     foreach my $i (@l) {
  886.     $IdCmap->{0}->[$i] =~ /(.*)\/(.+)/;
  887.     my $cmap = $2;
  888.     my @chints = split(' ', $IdCmap->{7}->[$i]);
  889.     
  890.     cid_register_all($font, $cmap, $reg, $ord, $chints[2], $chints[3],
  891.              $chints[4], $h);
  892.     }
  893.  
  894.     return 0;
  895. }
  896.  
  897. sub cid_unregister {
  898.     my $font = shift;
  899.     my $h = parse_hints_start(@_);
  900.  
  901.     my $reg = $h->{CIDRegistry};
  902.     my $ord = $h->{CIDOrdering};
  903.     my $fontname = $h->{FontName};
  904.     return 1 unless ($reg && $ord && $fontname);
  905.  
  906.     my $dir = '/CID/'.$reg.'-'.$ord.'/';
  907.  
  908.     remove_link($dir.'CIDFont/', $font, $fontname);
  909.  
  910.     if (exists($h->{AFM})) {
  911.     my $afm = $h->{AFM};
  912.  
  913.     remove_link($dir.'AFM/', $afm, $fontname.'.afm');
  914.     }
  915.  
  916.     defoma_id_unregister($IdCmap, type => 'real', font => $font);
  917.  
  918.     my @l = defoma_id_grep_cache($IdCmap, 'real', r0 => $reg.'-'.$ord.'/.*',
  919.                  f4 => 'cmap');
  920.  
  921.     foreach my $i (@l) {
  922.     $IdCmap->{0}->[$i] =~ /(.*)\/(.+)/;
  923.     my $cmap = $2;
  924.  
  925.     $font =~ /(.*)\/(.+)/;
  926.     my $cidfont = $reg.'-'.$ord.'/'.$2.'--'.$cmap;
  927.  
  928.     defoma_id_unregister($Id, type => 'alias', font => $cidfont);
  929.     defoma_id_unregister($Id, type => 'real', font => $cidfont);
  930.     }
  931.  
  932.     return 0;
  933. }
  934.  
  935. sub cid_install {
  936.     my $font = shift;
  937.     my $id = shift;
  938.     shift;
  939.     shift;
  940.  
  941.     defoma_font_register('xfont', $id, @_);
  942.     
  943.     return 0;
  944. }
  945.  
  946. sub cid_remove {
  947.     my $font = shift;
  948.     my $id = shift;
  949.     
  950.     defoma_font_unregister('xfont', $id);
  951.     
  952.     return 0;
  953. }
  954.  
  955. sub cid {
  956.     my $com = shift;
  957.  
  958.     if ($com eq 'register') {
  959.     return cid_register(@_);
  960.     } elsif ($com eq 'unregister') {
  961.     return cid_unregister(@_);
  962.     } elsif ($com eq 'do-install-real') {
  963.     return cid_install(@_);
  964.     } elsif ($com eq 'do-remove-real') {
  965.     return cid_remove(@_);
  966.     } elsif ($com eq 'init') {
  967.     return init();
  968.     } elsif ($com eq 'term') {
  969.     return cid_term();
  970.     }
  971.  
  972.     return 0;
  973. }
  974.  
  975. ###
  976.  
  977. sub cmap_register {
  978.     my $font = shift;
  979.     my $h = parse_hints_start(@_);
  980.  
  981.     my $cmap = $h->{CMapName};
  982.     my $reg = $h->{CIDRegistry};
  983.     my $ord = $h->{CIDOrdering};
  984.     return 1 unless ($cmap && $reg && $ord);
  985.  
  986.     my $cset = $h->{Charset};
  987.     my $enc = $h->{Encoding};
  988.     my $xenc = $h->{'X-RegistryEncoding'};
  989.  
  990.     return 1 unless ($xenc);
  991.     return 1 if ($h->{Direction} && $h->{Direction} eq 'Vertical');
  992.  
  993.     cid_check_dir($reg, $ord) && return 2;
  994.  
  995.     make_link('/CID/'.$reg.'-'.$ord.'/CMap/', $font, $cmap) && return 3;
  996.  
  997.     $cset = '.' unless ($cset);
  998.     $enc = '.' unless ($enc);
  999.  
  1000.     my $pri = $h->{Priority} || 0;
  1001.  
  1002.     defoma_id_register($IdCmap, type => 'real', font => $font,
  1003.                id => $reg.'-'.$ord.'/'.$cmap, priority => $pri,
  1004.                hints => join(' ', $reg, $ord, $cset, $enc, $xenc));
  1005.  
  1006.     my @l = defoma_id_grep_cache($IdCmap, 'real', r0 => $reg.'-'.$ord.'/.*',
  1007.                  f4 => 'cid');
  1008.  
  1009.     foreach my $i (@l) {
  1010.     my @hints = split(' ', $IdCmap->{7}->[$i]);
  1011.  
  1012.     shift(@hints);
  1013.     shift(@hints);
  1014.  
  1015.     my $h = parse_hints_start(@hints);
  1016.  
  1017.     cid_register_all($IdCmap->{1}->[$i], $cmap, $reg, $ord, $cset, $enc,
  1018.              $xenc, $h);
  1019.     }
  1020.  
  1021.     return 0;
  1022. }
  1023.  
  1024. sub cmap_unregister {
  1025.     my $font = shift;
  1026.     my $h = parse_hints_start(@_);
  1027.  
  1028.     my $cmap = $h->{CMapName};
  1029.     my $reg = $h->{CIDRegistry};
  1030.     my $ord = $h->{CIDOrdering};
  1031.  
  1032.     return unless ($cmap && $reg && $ord);
  1033.     
  1034.     remove_link('/CID/'.$reg.'-'.$ord.'/CMap/', $font, $cmap);
  1035.     
  1036.     defoma_id_unregister($IdCmap, type => 'real', font => $font);
  1037.  
  1038.     my @l = defoma_id_grep_cache($IdCmap, 'real', r0 => $reg.'-'.$ord.'/.*',
  1039.                  f4 => 'cid');
  1040.  
  1041.     foreach my $i (@l) {
  1042.     $IdCmap->{0}->[$i] =~ /(.*)\/(.+)/;
  1043.     my $cidfont = $reg.'-'.$ord.'/'.$2.'--'.$cmap.'.cid';
  1044.  
  1045.     defoma_id_unregister($Id, type => 'alias', font => $cidfont);
  1046.     defoma_id_unregister($Id, type => 'real', font => $cidfont);
  1047.     }
  1048.  
  1049.  
  1050.     return 0;
  1051. }
  1052.  
  1053. sub cmap {
  1054.     my $com = shift;
  1055.  
  1056.     if ($com eq 'register') {
  1057.     return cmap_register(@_);
  1058.     } elsif ($com eq 'unregister') {
  1059.     return cmap_unregister(@_);
  1060.     } elsif ($com eq 'init') {
  1061.     return init();
  1062.     } elsif ($com eq 'term') {
  1063.     return cid_term();
  1064.     }
  1065.  
  1066.     return 0;
  1067. }
  1068.  
  1069. 1;
  1070.